home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch8 / Bounce1b.frm (.txt) < prev    next >
Visual Basic Form  |  1999-05-28  |  9KB  |  254 lines
  1. VERSION 5.00
  2. Begin VB.Form frmBounce1b 
  3.    Caption         =   "Bounce1b"
  4.    ClientHeight    =   5235
  5.    ClientLeft      =   1320
  6.    ClientTop       =   825
  7.    ClientWidth     =   6870
  8.    LinkTopic       =   "Form1"
  9.    PaletteMode     =   1  'UseZOrder
  10.    ScaleHeight     =   349
  11.    ScaleMode       =   3  'Pixel
  12.    ScaleWidth      =   458
  13.    Begin VB.TextBox txtFramesPerSecond 
  14.       Height          =   285
  15.       Left            =   1440
  16.       TabIndex        =   4
  17.       Text            =   "20"
  18.       Top             =   4920
  19.       Width           =   375
  20.    End
  21.    Begin VB.TextBox txtNumBalls 
  22.       Height          =   285
  23.       Left            =   1440
  24.       TabIndex        =   3
  25.       Text            =   "20"
  26.       Top             =   4560
  27.       Width           =   375
  28.    End
  29.    Begin VB.CommandButton cmdStart 
  30.       Caption         =   "Start"
  31.       Default         =   -1  'True
  32.       Height          =   495
  33.       Left            =   2160
  34.       TabIndex        =   1
  35.       Top             =   4620
  36.       Width           =   855
  37.    End
  38.    Begin VB.PictureBox picCourt 
  39.       AutoRedraw      =   -1  'True
  40.       Height          =   4455
  41.       Left            =   0
  42.       ScaleHeight     =   293
  43.       ScaleMode       =   3  'Pixel
  44.       ScaleWidth      =   453
  45.       TabIndex        =   0
  46.       Top             =   0
  47.       Width           =   6855
  48.    End
  49.    Begin VB.Label Label1 
  50.       Caption         =   "Frames per second:"
  51.       Height          =   255
  52.       Index           =   0
  53.       Left            =   0
  54.       TabIndex        =   5
  55.       Top             =   4920
  56.       Width           =   1455
  57.    End
  58.    Begin VB.Label Label1 
  59.       Caption         =   "Number of balls:"
  60.       Height          =   255
  61.       Index           =   1
  62.       Left            =   0
  63.       TabIndex        =   2
  64.       Top             =   4560
  65.       Width           =   1455
  66.    End
  67. Attribute VB_Name = "frmBounce1b"
  68. Attribute VB_GlobalNameSpace = False
  69. Attribute VB_Creatable = False
  70. Attribute VB_PredeclaredId = True
  71. Attribute VB_Exposed = False
  72. Option Explicit
  73. Private xmax As Integer
  74. Private ymax As Integer
  75. Private NumBalls As Integer
  76. Private BallX() As Integer
  77. Private BallY() As Integer
  78. Private BallDx() As Integer
  79. Private BallDy() As Integer
  80. Private BallRadius() As Integer
  81. Private BallColor() As Long
  82. Private Playing As Boolean
  83. Private NumPlayed As Long
  84. Private BitmapWid As Long
  85. Private BitmapHgt As Long
  86. Private BitmapNumBytes As Long
  87. Private Bytes() As Byte
  88. ' Bitmap Information
  89. Private Type BITMAP
  90.     bmType As Long
  91.     bmWidth As Long
  92.     bmHeight As Long
  93.     bmWidthBytes As Long
  94.     bmPlanes As Integer
  95.     bmBitsPixel As Integer
  96.     bmBits As Long
  97. End Type
  98. Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
  99. Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
  100. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  101. ' Draw some random rectangles on the bacground.
  102. Private Sub DrawBackground()
  103. Dim i As Integer
  104. Dim wid As Single
  105. Dim hgt As Single
  106.     ' Start with a clean slate.
  107.     picCourt.Line (0, 0)-(picCourt.ScaleWidth, picCourt.ScaleHeight), picCourt.BackColor, BF
  108.     ' Draw some rectangles.
  109.     For i = 1 To 10
  110.         hgt = 10 + Rnd * xmax / 3
  111.         wid = 10 + Rnd * ymax / 3
  112.         picCourt.Line (Int(Rnd * xmax), Int(Rnd * ymax))-Step(hgt, wid), QBColor(Int(Rnd * 16)), BF
  113.     Next i
  114.     ' Make the rectangles part of the permanent background.
  115.     picCourt.Picture = picCourt.Image
  116. End Sub
  117. ' Generate some random data.
  118. Private Sub InitData()
  119. Dim ball As Integer
  120. Dim R As Integer
  121. Dim clr As Integer
  122.     ' See how many balls there should be.
  123.     If Not IsNumeric(txtNumBalls.Text) Then _
  124.         txtNumBalls.Text = "10"
  125.     NumBalls = CInt(txtNumBalls.Text)
  126.     ReDim BallRadius(1 To NumBalls)
  127.     ReDim BallX(1 To NumBalls)
  128.     ReDim BallY(1 To NumBalls)
  129.     ReDim BallDx(1 To NumBalls)
  130.     ReDim BallDy(1 To NumBalls)
  131.     ReDim BallColor(1 To NumBalls)
  132.     ' Set the initial ball data.
  133.     For ball = 1 To NumBalls
  134.         R = Int(10 * Rnd + 5)
  135.         BallRadius(ball) = R
  136.         BallX(ball) = Int((xmax - R + 1) * Rnd)
  137.         BallY(ball) = Int((ymax - R + 1) * Rnd)
  138.         BallDx(ball) = Int(21 * Rnd - 10)
  139.         BallDy(ball) = Int(21 * Rnd - 10)
  140.         clr = Int(15 * Rnd)
  141.         If clr >= 7 Then clr = clr + 1
  142.         BallColor(ball) = QBColor(clr)
  143.     Next ball
  144. End Sub
  145. ' Start the animation.
  146. Private Sub cmdStart_Click()
  147.     If Playing Then
  148.         Playing = False
  149.         cmdStart.Caption = "Stopped"
  150.         cmdStart.Enabled = False
  151.     Else
  152.         cmdStart.Caption = "Stop"
  153.         Playing = True
  154.         InitData
  155.         PlayData
  156.         Playing = False
  157.         cmdStart.Caption = "Start"
  158.         cmdStart.Enabled = True
  159.     End If
  160. End Sub
  161. ' Play the animation.
  162. Private Sub PlayData()
  163. Dim ms_per_frame As Long
  164. Dim start_time As Single
  165. Dim stop_time As Single
  166. Dim bm As BITMAP
  167.     ' Draw a random background.
  168.     DrawBackground
  169.     ' Save the background bitmap data.
  170.     GetObject picCourt.Image, Len(bm), bm
  171.     BitmapWid = bm.bmWidthBytes
  172.     BitmapHgt = bm.bmHeight
  173.     BitmapNumBytes = BitmapWid * BitmapHgt
  174.     ReDim Bytes(1 To bm.bmWidthBytes, 1 To bm.bmHeight)
  175.     GetBitmapBits picCourt.Image, BitmapNumBytes, Bytes(1, 1)
  176.     ' See how fast we should go.
  177.     If Not IsNumeric(txtFramesPerSecond.Text) Then _
  178.         txtFramesPerSecond.Text = "10"
  179.     ms_per_frame = 1000 \ CLng(txtFramesPerSecond.Text)
  180.     ' Start the animation.
  181.     NumPlayed = 0
  182.     start_time = Timer
  183.     PlayImages ms_per_frame
  184.     ' Display results.
  185.     stop_time = Timer
  186.     MsgBox "Displayed" & Str$(NumPlayed) & _
  187.         " frames in " & _
  188.         Format$(stop_time - start_time, "0.00") & _
  189.         " seconds (" & _
  190.         Format$(NumPlayed / (stop_time - start_time), "0.00") & _
  191.         " FPS)."
  192. End Sub
  193. ' Play the animation.
  194. Private Sub PlayImages(ByVal ms_per_frame As Long)
  195. Dim ball As Integer
  196. Dim next_time As Long
  197.     ' Get the current time.
  198.     next_time = GetTickCount()
  199.     ' Start the animation.
  200.     Do While Playing
  201.         NumPlayed = NumPlayed + 1
  202.         ' Restore the background.
  203.         SetBitmapBits picCourt.Image, BitmapNumBytes, Bytes(1, 1)
  204.         ' Draw the balls.
  205.         For ball = 1 To NumBalls
  206.             picCourt.FillColor = BallColor(ball)
  207.             picCourt.Circle _
  208.                 (BallX(ball), BallY(ball)), _
  209.                 BallRadius(ball), BallColor(ball)
  210.         Next ball
  211.         ' Move the balls for the next frame,
  212.         ' keeping them within picCourt.
  213.         For ball = 1 To NumBalls
  214.             BallX(ball) = BallX(ball) + BallDx(ball)
  215.             If BallX(ball) < BallRadius(ball) Then
  216.                 BallX(ball) = 2 * BallRadius(ball) - BallX(ball)
  217.                 BallDx(ball) = -BallDx(ball)
  218.             ElseIf BallX(ball) > xmax - BallRadius(ball) Then
  219.                 BallX(ball) = 2 * (xmax - BallRadius(ball)) - BallX(ball)
  220.                 BallDx(ball) = -BallDx(ball)
  221.             End If
  222.             BallY(ball) = BallY(ball) + BallDy(ball)
  223.             If BallY(ball) < BallRadius(ball) Then
  224.                 BallY(ball) = 2 * BallRadius(ball) - BallY(ball)
  225.                 BallDy(ball) = -BallDy(ball)
  226.             ElseIf BallY(ball) > ymax - BallRadius(ball) Then
  227.                 BallY(ball) = 2 * (ymax - BallRadius(ball)) - BallY(ball)
  228.                 BallDy(ball) = -BallDy(ball)
  229.             End If
  230.         Next ball
  231.         ' Wait until it's time for the next frame.
  232.         next_time = next_time + ms_per_frame
  233.         WaitTill next_time
  234.     Loop
  235. End Sub
  236. Private Sub Form_Load()
  237.     Randomize
  238.     ' Set FillStyle to vbSolid.
  239.     picCourt.FillStyle = vbSolid
  240. End Sub
  241. ' Make the ball court nice and big.
  242. Private Sub Form_Resize()
  243. Const GAP = 3
  244.     txtFramesPerSecond.Top = ScaleHeight - GAP - txtFramesPerSecond.Height
  245.     Label1(0).Top = txtFramesPerSecond.Top
  246.     txtNumBalls.Top = txtFramesPerSecond.Top - GAP - txtNumBalls.Height
  247.     Label1(1).Top = txtNumBalls.Top
  248.     cmdStart.Top = (txtNumBalls.Top + txtFramesPerSecond.Top + txtFramesPerSecond.Height - cmdStart.Height) / 2
  249.     picCourt.Move 0, 0, ScaleWidth, txtNumBalls.Top - GAP
  250.     xmax = picCourt.ScaleWidth - 1
  251.     ymax = picCourt.ScaleHeight - 1
  252.     picCourt.Picture = picCourt.Image
  253. End Sub
  254.